home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / faq-s.zip / TEXTRET.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-21  |  10KB  |  395 lines
  1. {$R-,S-,I-,D-,F-,V-,B-,N-,L+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit textret;
  5.  
  6. interface
  7.  
  8. uses crt,gentypes,gensubs,subs1;
  9.  
  10. procedure reloadtext (sector:integer; var q:message);
  11. procedure deletetext (sector:integer);
  12. function maketext (var q:message):integer;
  13. function copytext (sector:integer):integer;
  14. procedure printtext (sector:integer);
  15.  
  16. implementation
  17.  
  18. procedure reloadtext (sector:integer; var q:message);
  19. var k:char;
  20.     sectorptr,tmp,n:integer;
  21.     buff:buffer;
  22.     x:boolean;
  23.  
  24.   procedure setbam (sector,val:integer);
  25.   begin
  26.     seek (mapfile,sector);
  27.     write (mapfile,val)
  28.   end;
  29.  
  30.   procedure chk;
  31.   begin
  32.     iocode:=ioresult;
  33.     if iocode<>0 then writeln (usr,'[Error #',iocode,' reading message]')
  34.   end;
  35.  
  36. begin
  37.   sectorptr:=32767;
  38.   n:=1;
  39.   q.text[1]:='';
  40.   repeat
  41.     if sectorptr>sectorsize then begin
  42.       if sector<0 then exit;
  43.       seek (tfile,sector); chk;
  44.       read (tfile,buff); chk;
  45.       seek (mapfile,sector); chk;
  46.       read (mapfile,tmp); chk;
  47.       if tmp=-2 then begin
  48.         tmp:=-1;
  49.         seek (mapfile,sector); chk;
  50.         write (mapfile,tmp); chk;
  51.       end;
  52.       sector:=tmp;
  53.       sectorptr:=1
  54.     end;
  55.     k:=buff[sectorptr];
  56.     case k of
  57.       #0,#10:;
  58.       #13:if n>=maxmessagesize
  59.             then k:=#0
  60.             else begin
  61.               n:=n+1;
  62.               q.text[n]:=''
  63.             end
  64.       else q.text[n]:=q.text[n]+k
  65.     end;
  66.     sectorptr:=sectorptr+1
  67.   until k=#0;
  68.   q.numlines:=n;
  69.   chk
  70. end;
  71.  
  72. procedure deletetext (sector:integer);
  73. var next:integer;
  74.  
  75.   procedure setbam (sector,val:integer);
  76.   begin
  77.     seek (mapfile,sector);
  78.     write (mapfile,val)
  79.   end;
  80.  
  81. begin
  82.   while sector>=0 do begin
  83.     seek (mapfile,sector);
  84.     read (mapfile,next);
  85.     setbam (sector,-2);
  86.     sector:=next
  87.   end
  88. end;
  89.  
  90. function maketext (var q:message):integer;
  91. var line,pos,sector,prev:integer;
  92.     bufptr:integer;
  93.     curline:anystr;
  94.     k:char;
  95.     buff:buffer;
  96.  
  97.   procedure setbam (sector,val:integer);
  98.   begin
  99.     seek (mapfile,sector);
  100.     write (mapfile,val)
  101.   end;
  102.  
  103.   function nextblank (first:integer; linkit:boolean):integer;
  104.   var cnt,i,blank:integer;
  105.   begin
  106.     nextblank:=-1;
  107.     if first<-1 then first:=-1;
  108.     if first>=numsectors then exit;
  109.     seek (mapfile,first+1);
  110.     for cnt:=first+1 to numsectors do begin
  111.       read (mapfile,i);
  112.       if i=-2 then begin
  113.         blank:=cnt;
  114.         if (first>=0) and linkit then setbam (first,blank);
  115.         nextblank:=blank;
  116.         exit
  117.       end
  118.     end
  119.   end;
  120.  
  121.   function firstblank:integer;
  122.   begin
  123.     firstblank:=nextblank (-1,false)
  124.   end;
  125.  
  126.   procedure ensuretfilesize (sector:integer);
  127.   var cnt:integer;
  128.       buff:buffer;
  129.   begin
  130.     if sector<filesize(tfile) then exit;
  131.     if (sector<0) or (sector>numsectors) then exit;
  132.     fillchar (buff,sizeof(buff),'*');
  133.     seek (tfile,filesize(tfile));
  134.     for cnt:=filesize(tfile) to sector do write (tfile,buff);
  135.     fillchar (buff,sizeof(buff),'!')
  136.   end;
  137.  
  138.   procedure writesector (sector:integer; var q:buffer);
  139.   var n:integer;
  140.   begin
  141.     if (sector<0) or (sector>numsectors) then exit;
  142.     seek (mapfile,sector);
  143.     read (mapfile,n);
  144.     if n<>-2 then begin
  145.       error ('Overwrite error sector=%1!','',strr(sector));
  146.       exit
  147.     end;
  148.     ensuretfilesize (sector);
  149.     seek (tfile,sector);
  150.     write (tfile,q)
  151.   end;
  152.  
  153.   procedure flushbuf;
  154.   begin
  155.     writesector (sector,buff);
  156.     prev:=sector;
  157.     sector:=nextblank(prev,true);
  158.     bufptr:=1;
  159.   end;
  160.  
  161.   procedure outofroom;
  162.   begin
  163.     writeln (^B'Sorry, out of room!');
  164.     maketext:=-1
  165.   end;
  166.  
  167. begin
  168.   if q.numlines=0 then begin
  169.     writeln (^B'Message blank!');
  170.     maketext:=-1;
  171.     exit
  172.   end;
  173.   if firstfree>=0 then begin
  174.     sector:=firstfree;
  175.     seek (mapfile,sector);
  176.     read (mapfile,prev)
  177.   end else prev:=-1;
  178.   if prev<>-2 then begin
  179.     firstfree:=firstblank;
  180.     sector:=firstfree
  181.   end;
  182.   maketext:=sector;
  183.   if sector=-1 then begin
  184.     outofroom;
  185.     exit
  186.   end;
  187.   bufptr:=1;
  188.   for line:=1 to q.numlines do begin
  189.     curline:=q.text[line]+^M;
  190.     if line=q.numlines then curline:=curline+chr(0);
  191.     for pos:=1 to length(curline) do begin
  192.       k:=curline[pos];
  193.       buff[bufptr]:=k;
  194.       bufptr:=bufptr+1;
  195.       if bufptr>sectorsize then begin
  196.         flushbuf;
  197.         if sector=-1 then begin
  198.           outofroom;
  199.           exit
  200.         end
  201.       end
  202.     end
  203.   end;
  204.   if bufptr>1 then flushbuf;
  205.   setbam (prev,-1);
  206.   firstfree:=nextblank(firstfree,false);
  207.   if firstfree=-1 then firstfree:=firstblank
  208. end;
  209.  
  210. function copytext (sector:integer):integer;
  211. var me:message;
  212. begin
  213.   reloadtext (sector,me);
  214.   copytext:=maketext (me)
  215. end;
  216.  
  217. procedure printtext (sector:integer);
  218. var q:message;
  219.     x,bub,done:boolean;
  220.     n,m,t,w,b,y,mm,i,apexiscool,e:integer;
  221.     p:byte;
  222.     s,a,cornerstone,sunbane:string;
  223.     cs,css,keithmillerisafag:char;
  224.     kay,thegog:char;
  225. begin
  226.   reloadtext (sector,q);
  227.   writeln (^B);
  228.   n:=1;
  229.   repeat
  230.    mm:=0;
  231.    repeat
  232.     if length(q.text[n])>0 then begin
  233.     p:=0;
  234.     mm:=mm+1;
  235.     s:=copy(q.text[n],mm,1);
  236.     if s='/' then p:=mm
  237.      else p:=0;
  238.     if p>0 then begin
  239.      cornerstone:=copy(q.text[n],p+1,1);
  240.      sunbane:=copy(q.text[n],p+2,1);
  241.      a:=(upcase(cornerstone[1]))+(upcase(sunbane[1]));
  242.      if
  243.       (a='00') or (a='01') or (a='02') or (a='03') or (a='04') or (a='05') or
  244.       (a='06') or (a='07') or (a='08') or (a='09') or (a='10') or (a='11') or
  245.       (a='12') or (a='13') or (a='14') or (a='15') or (a='16') or (a='17') or
  246.       (a='18') or (a='19') or (a='20') or (a='21') or (a='22') or (a='23') or
  247.       (a='KE') or (a='UN') or (a='CL') or (a='TI') or (a='DA') or (a='PW') or
  248.       ((a[1]='P') and (valu(a[2])>0))
  249.       then begin
  250.       if
  251.       (a='00') or (a='01') or (a='02') or (a='03') or (a='04') or (a='05') or
  252.       (a='06') or (a='07') or (a='08') or (a='09') or (a='10') or (a='11') or
  253.       (a='12') or (a='13') or (a='14') or (a='15') or (a='16') or (a='17') or
  254.       (a='18') or (a='19') or (a='20') or (a='21') or (a='22') or (a='23') then
  255.      begin
  256.       delete (q.text[n],p+1,2);
  257.       b:=valu(a);
  258.       case b of
  259.        16:case curattrib of
  260.            0..15:b:=curattrib;
  261.            16..31:b:=curattrib-16;
  262.            32..47:b:=curattrib-32;
  263.            48..63:b:=curattrib-48;
  264.            64..79:b:=curattrib-64;
  265.            80..95:b:=curattrib-80;
  266.            96..111:b:=curattrib-96;
  267.            112..127:b:=curattrib-111;
  268.           end;
  269.        17:case curattrib of
  270.            0..15:b:=curattrib+16;
  271.            16..31:b:=curattrib;
  272.            32..47:b:=curattrib-16;
  273.            48..63:b:=curattrib-32;
  274.            64..79:b:=curattrib-48;
  275.            80..95:b:=curattrib-64;
  276.            96..111:b:=curattrib-80;
  277.            112..127:b:=curattrib-96;
  278.           end;
  279.        18:case curattrib of
  280.            0..15:b:=curattrib+32;
  281.            16..31:b:=curattrib+16;
  282.            32..47:b:=curattrib;
  283.            48..63:b:=curattrib-16;
  284.            64..79:b:=curattrib-32;
  285.            80..95:b:=curattrib-48;
  286.            96..111:b:=curattrib-64;
  287.            112..127:b:=curattrib-80;
  288.           end;
  289.        19:case curattrib of
  290.            0..15:b:=curattrib+48;
  291.            16..31:b:=curattrib+32;
  292.            32..47:b:=curattrib+16;
  293.            48..63:b:=curattrib;
  294.            64..79:b:=curattrib-16;
  295.            80..95:b:=curattrib-32;
  296.            96..111:b:=curattrib-48;
  297.            112..127:b:=curattrib-64;
  298.           end;
  299.        20:case curattrib of
  300.            0..15:b:=curattrib+64;
  301.            16..31:b:=curattrib+48;
  302.            32..47:b:=curattrib+32;
  303.            48..63:b:=curattrib+16;
  304.            64..79:b:=curattrib;
  305.            80..95:b:=curattrib-16;
  306.            96..111:b:=curattrib-32;
  307.            112..127:b:=curattrib-48;
  308.           end;
  309.        21:case curattrib of
  310.            0..15:b:=curattrib+80;
  311.            16..31:b:=curattrib+64;
  312.            32..47:b:=curattrib+48;
  313.            48..63:b:=curattrib+32;
  314.            64..79:b:=curattrib+16;
  315.            80..95:b:=curattrib;
  316.            96..111:b:=curattrib-16;
  317.            112..127:b:=curattrib-32;
  318.           end;
  319.        22:case curattrib of
  320.            0..15:b:=curattrib+96;
  321.            16..31:b:=curattrib+80;
  322.            32..47:b:=curattrib+64;
  323.            48..63:b:=curattrib+48;
  324.            64..79:b:=curattrib+32;
  325.            80..95:b:=curattrib+16;
  326.            96..111:b:=curattrib;
  327.            112..127:b:=curattrib-16;
  328.           end;
  329.        23:case curattrib of
  330.            0..15:b:=curattrib+111;
  331.            16..31:b:=curattrib+96;
  332.            32..47:b:=curattrib+80;
  333.            48..63:b:=curattrib+64;
  334.            64..79:b:=curattrib+48;
  335.            80..95:b:=curattrib+32;
  336.            96..111:b:=curattrib+16;
  337.            112..127:b:=curattrib;
  338.           end;
  339.         end;
  340.       if b=0 then begin
  341.        ansicolor (0);
  342.       end else
  343.       ansicolor (b);
  344.      end;
  345.      end;
  346.      if a='UN' then
  347.      begin
  348.       delete (q.text[n],p+1,1);
  349.       delete (q.text[n],p+1,1);
  350.       write (urec.handle);
  351.      end;
  352.      if a='PW' then begin
  353.       delete (q.text[n],p+1,1);
  354.       delete (q.text[n],p+1,1);
  355.       write (urec.password);
  356.      end;
  357.      if a='TI' then
  358.      begin
  359.       delete (q.text[n],p+1,1);
  360.       delete (q.text[n],p+1,1);
  361.       write (timestr(now));
  362.      end;
  363.      if a='DA' then
  364.      begin
  365.       delete (q.text[n],p+1,1);
  366.       delete (q.text[n],p+1,1);
  367.       write (datestr(now));
  368.      end;
  369.      if a='CL' then
  370.      begin
  371.       delete (q.text[n],p+1,1);
  372.       delete (q.text[n],p+1,1);
  373.       if ansigraphics in urec.config then write (#27+'[2J') else write (^L);
  374.      end;
  375.      if ((a[1]='P') and (valu(a[2])>0)) then
  376.      begin
  377.       delete (q.text[n],p+1,1); {??}
  378.       delete (q.text[n],p+1,1); {??}
  379.       apexiscool:=valu(a[2]);
  380.       delay (apexiscool*1000);
  381.      end;
  382.    end else write (s);
  383.   end;
  384.   until mm=length(q.text[n]);
  385.    writeln;
  386.    n:=n+1;
  387.   until break or (n>q.numlines) or hungupon;
  388.   x:=xpressed; bub:=break;
  389.   writeln (^B^M);
  390.   xpressed:=x; break:=bub;
  391.   ansicolor (urec.regularcolor)
  392. end;
  393.  
  394. begin
  395. end.